home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1993 / MacHack 1993.toast / MacHack™ 1987-1992 / MacHack™ '87 / Source ƒ / XLISP ƒ / XLISP 1.7 C SRCS / xlcont.c < prev    next >
Encoding:
C/C++ Source or Header  |  1986-07-07  |  19.1 KB  |  961 lines  |  [TEXT/????]
  1. /* xlcont - xlisp special forms */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "overflow"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE *xlenv,*xlvalue;
  14. extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref;
  15. extern NODE *s_lambda,*s_macro;
  16. extern NODE *s_comma,*s_comat;
  17. extern NODE *true;
  18.  
  19. /* forward declarations */
  20. FORWARD NODE *bquote1();
  21. FORWARD NODE *defun();
  22. FORWARD NODE *let();
  23. FORWARD NODE *prog();
  24. FORWARD NODE *progx();
  25. FORWARD NODE *doloop();
  26.  
  27. /* xquote - special form 'quote' */
  28. NODE *xquote(args)
  29.   NODE *args;
  30. {
  31.     if (atom(args))
  32.     xlfail("too few arguments");
  33.     else if (cdr(args) != NIL)
  34.     xlfail("too many arguments");
  35.     return (car(args));
  36. }
  37.  
  38. /* xfunction - special form 'function' */
  39. NODE *xfunction(args)
  40.   NODE *args;
  41. {
  42.     NODE *val;
  43.  
  44.     /* get the argument */
  45.     val = xlarg(&args);
  46.     xllastarg(args);
  47.  
  48.     /* create a closure for lambda expressions */
  49.     if (consp(val) && car(val) == s_lambda)
  50.     val = cons(val,xlenv);
  51.  
  52.     /* otherwise, get the value of a symbol */
  53.     else if (symbolp(val))
  54.     val = xlgetvalue(val);
  55.  
  56.     /* otherwise, its an error */
  57.     else
  58.     xlerror("not a function",val);
  59.  
  60.     /* return the function */
  61.     return (val);
  62. }
  63.  
  64. /* xlambda - special form 'lambda' */
  65. NODE *xlambda(args)
  66.   NODE *args;
  67. {
  68.     NODE *fargs;
  69.  
  70.     /* get the formal argument list */
  71.     fargs = xlmatch(LIST,&args);
  72.  
  73.     /* create a new function definition */
  74.     return (cons(cons(s_lambda,cons(fargs,args)),xlenv));
  75. }
  76.  
  77. /* xbquote - back quote special form */
  78. NODE *xbquote(args)
  79.   NODE *args;
  80. {
  81.     NODE *expr;
  82.  
  83.     /* get the expression */
  84.     expr = xlarg(&args);
  85.     xllastarg(args);
  86.  
  87.     /* fill in the template */
  88.     return (bquote1(expr));
  89. }
  90.  
  91. /* bquote1 - back quote helper function */
  92. LOCAL NODE *bquote1(expr)
  93.   NODE *expr;
  94. {
  95.     NODE ***oldstk,*val,*list,*last,*new;
  96.  
  97.     /* handle atoms */
  98.     if (atom(expr))
  99.     val = expr;
  100.  
  101.     /* handle (comma <expr>) */
  102.     else if (car(expr) == s_comma) {
  103.     if (atom(cdr(expr)))
  104.         xlfail("bad comma expression");
  105.     val = xleval(car(cdr(expr)));
  106.     }
  107.  
  108.     /* handle ((comma-at <expr>) ... ) */
  109.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  110.     oldstk = xlstack;
  111.     xlstkcheck(2);
  112.     xlsave(list);
  113.     xlsave(val);
  114.     if (atom(cdr(car(expr))))
  115.         xlfail("bad comma-at expression");
  116.     list = xleval(car(cdr(car(expr))));
  117.     for (last = NIL; consp(list); list = cdr(list)) {
  118.         new = consa(car(list));
  119.         if (last)
  120.         rplacd(last,new);
  121.         else
  122.         val = new;
  123.         last = new;
  124.     }
  125.     if (last)
  126.         rplacd(last,bquote1(cdr(expr)));
  127.     else
  128.         val = bquote1(cdr(expr));
  129.     xlstack = oldstk;
  130.     }
  131.  
  132.     /* handle any other list */
  133.     else {
  134.     oldstk = xlstack;
  135.     xlsave1(val);
  136.     val = consa(NIL);
  137.     rplaca(val,bquote1(car(expr)));
  138.     rplacd(val,bquote1(cdr(expr)));
  139.     xlstack = oldstk;
  140.     }
  141.  
  142.     /* return the result */
  143.     return (val);
  144. }
  145.  
  146. /* xsetq - special form 'setq' */
  147. NODE *xsetq(args)
  148.   NODE *args;
  149. {
  150.     NODE *sym,*val;
  151.  
  152.     /* handle each pair of arguments */
  153.     for (val = NIL; args; ) {
  154.     sym = xlmatch(SYM,&args);
  155.     val = xlevarg(&args);
  156.     xlsetvalue(sym,val);
  157.     }
  158.  
  159.     /* return the result value */
  160.     return (val);
  161. }
  162.  
  163. /* xsetf - special form 'setf' */
  164. NODE *xsetf(args)
  165.   NODE *args;
  166. {
  167.     NODE ***oldstk,*place,*value;
  168.  
  169.     /* create a new stack frame */
  170.     oldstk = xlstack;
  171.     xlsave1(value);
  172.  
  173.     /* handle each pair of arguments */
  174.     while (args) {
  175.  
  176.     /* get place and value */
  177.     place = xlarg(&args);
  178.     value = xlevarg(&args);
  179.  
  180.     /* check the place form */
  181.     if (symbolp(place))
  182.         xlsetvalue(place,value);
  183.     else if (consp(place))
  184.         placeform(place,value);
  185.     else
  186.         xlfail("bad place form");
  187.     }
  188.  
  189.     /* restore the previous stack frame */
  190.     xlstack = oldstk;
  191.  
  192.     /* return the value */
  193.     return (value);
  194. }
  195.  
  196. /* placeform - handle a place form other than a symbol */
  197. LOCAL placeform(place,value)
  198.   NODE *place,*value;
  199. {
  200.     NODE ***oldstk,*fun,*arg1,*arg2;
  201.     int i;
  202.  
  203.     /* check the function name */
  204.     if ((fun = xlmatch(SYM,&place)) == s_get) {
  205.     oldstk = xlstack;
  206.     xlstkcheck(2);
  207.     xlsave(arg1);
  208.     xlsave(arg2);
  209.     arg1 = xlevmatch(SYM,&place);
  210.     arg2 = xlevmatch(SYM,&place);
  211.     xllastarg(place);
  212.     xlputprop(arg1,value,arg2);
  213.     xlstack = oldstk;
  214.     }
  215.     else if (fun == s_svalue) {
  216.     oldstk = xlstack;
  217.     xlsave1(arg1);
  218.     arg1 = xlevmatch(SYM,&place);
  219.     xllastarg(place);
  220.     setvalue(arg1,value);
  221.     xlstack = oldstk;
  222.     }
  223.     else if (fun == s_splist) {
  224.     oldstk = xlstack;
  225.     xlsave1(arg1);
  226.     arg1 = xlevmatch(SYM,&place);
  227.     xllastarg(place);
  228.     setplist(arg1,value);
  229.     xlstack = oldstk;
  230.     }
  231.     else if (fun == s_car) {
  232.     oldstk = xlstack;
  233.     xlsave1(arg1);
  234.     if ((arg1 = xlevmatch(LIST,&place)) == NIL)
  235.         xlerror("bad argument type",arg1);
  236.     xllastarg(place);
  237.     rplaca(arg1,value);
  238.     xlstack = oldstk;
  239.     }
  240.     else if (fun == s_cdr) {
  241.     oldstk = xlstack;
  242.     xlsave1(arg1);
  243.     if ((arg1 = xlevmatch(LIST,&place)) == NIL)
  244.         xlerror("bad argument type",arg1);
  245.     xllastarg(place);
  246.     rplacd(arg1,value);
  247.     xlstack = oldstk;
  248.     }
  249.     else if (fun == s_nth) {
  250.     oldstk = xlstack;
  251.     xlstkcheck(2);
  252.     xlsave(arg1);
  253.     xlsave(arg2);
  254.     arg1 = xlevmatch(INT,&place);
  255.     arg2 = xlevmatch(LIST,&place);
  256.     xllastarg(place);
  257.     for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
  258.         arg2 = cdr(arg2);
  259.     if (consp(arg2))
  260.         rplaca(arg2,value);
  261.     xlstack = oldstk;
  262.     }
  263.  
  264.     else if (fun == s_aref) {
  265.     oldstk = xlstack;
  266.     xlstkcheck(2);
  267.     xlsave(arg1);
  268.     xlsave(arg2);
  269.     arg1 = xlevmatch(VECT,&place);
  270.     arg2 = xlevmatch(INT,&place); i = (int)getfixnum(arg2);
  271.     xllastarg(place);
  272.     if (i < 0 || i >= getsize(arg1))
  273.         xlerror("index out of range",arg2);
  274.     setelement(arg1,i,value);
  275.     xlstack = oldstk;
  276.     }
  277.     else
  278.     xlfail("bad place form");
  279. }
  280.                
  281. /* xdefun - special form 'defun' */
  282. NODE *xdefun(args)
  283.   NODE *args;
  284. {
  285.     return (defun(args,s_lambda));
  286. }
  287.  
  288. /* xdefmacro - special form 'defmacro' */
  289. NODE *xdefmacro(args)
  290.   NODE *args;
  291. {
  292.     return (defun(args,s_macro));
  293. }
  294.  
  295. /* defun - internal function definition routine */
  296. LOCAL NODE *defun(args,type)
  297.   NODE *args,*type;
  298. {
  299.     NODE *sym,*fargs;
  300.  
  301.     /* get the function symbol and formal argument list */
  302.     sym = xlmatch(SYM,&args);
  303.     fargs = xlmatch(LIST,&args);
  304.  
  305.     /* make the symbol point to a new function definition */
  306.     xlsetvalue(sym,cons(cons(type,cons(fargs,args)),xlenv));
  307.  
  308.     /* return the function symbol */
  309.     return (sym);
  310. }
  311.  
  312. /* xcond - special form 'cond' */
  313. NODE *xcond(args)
  314.   NODE *args;
  315. {
  316.     NODE *list,*val;
  317.  
  318.     /* find a predicate that is true */
  319.     for (val = NIL; consp(args); args = cdr(args)) {
  320.  
  321.     /* get the next conditional */
  322.     list = car(args);
  323.  
  324.     /* evaluate the predicate part */
  325.     if (consp(list) && (val = xleval(car(list)))) {
  326.  
  327.         /* evaluate each expression */
  328.         for (list = cdr(list); consp(list); list = cdr(list))
  329.         val = xleval(car(list));
  330.  
  331.         /* exit the loop */
  332.         break;
  333.     }
  334.     }
  335.  
  336.     /* return the value */
  337.     return (val);
  338. }
  339.  
  340. /* xcase - special form 'case' */
  341. NODE *xcase(args)
  342.   NODE *args;
  343. {
  344.     NODE ***oldstk,*key,*list,*cases,*val;
  345.  
  346.     /* create a new stack frame */
  347.     oldstk = xlstack;
  348.     xlsave1(key);
  349.  
  350.     /* get the key expression */
  351.     key = xlevarg(&args);
  352.  
  353.     /* find a case that matches */
  354.     for (val = NIL; consp(args); args = cdr(args)) {
  355.  
  356.     /* get the next case clause */
  357.     list = car(args);
  358.  
  359.     /* make sure this is a valid clause */
  360.     if (consp(list)) {
  361.  
  362.         /* compare the key list against the key */
  363.         if ((cases = car(list)) == true ||
  364.                 (listp(cases) && keypresent(key,cases)) ||
  365.                 eql(key,cases)) {
  366.  
  367.         /* evaluate each expression */
  368.         for (list = cdr(list); consp(list); list = cdr(list))
  369.             val = xleval(car(list));
  370.  
  371.         /* exit the loop */
  372.         break;
  373.         }
  374.     }
  375.     else
  376.         xlerror("bad case clause",list);
  377.     }
  378.  
  379.     /* restore the previous stack frame */
  380.     xlstack = oldstk;
  381.  
  382.     /* return the value */
  383.     return (val);
  384. }
  385.  
  386. /* keypresent - check for the presence of a key in a list */
  387. LOCAL int keypresent(key,list)
  388.   NODE *key,*list;
  389. {
  390.     for (; consp(list); list = cdr(list))
  391.     if (eql(car(list),key))
  392.         return (TRUE);
  393.     return (FALSE);
  394. }
  395.  
  396. /* xand - special form 'and' */
  397. NODE *xand(args)
  398.   NODE *args;
  399. {
  400.     NODE *val;
  401.  
  402.     /* evaluate each argument */
  403.     for (val = true; consp(args); args = cdr(args))
  404.     if ((val = xleval(car(args))) == NIL)
  405.         break;
  406.  
  407.     /* return the result value */
  408.     return (val);
  409. }
  410.  
  411. /* xor - special form 'or' */
  412. NODE *xor(args)
  413.   NODE *args;
  414. {
  415.     NODE *val;
  416.  
  417.     /* evaluate each argument */
  418.     for (val = NIL; consp(args); args = cdr(args))
  419.     if ((val = xleval(car(args))))
  420.         break;
  421.  
  422.     /* return the result value */
  423.     return (val);
  424. }
  425.  
  426. /* xif - special form 'if' */
  427. NODE *xif(args)
  428.   NODE *args;
  429. {
  430.     NODE *testexpr,*thenexpr,*elseexpr;
  431.  
  432.     /* get the test expression, then clause and else clause */
  433.     testexpr = xlarg(&args);
  434.     thenexpr = xlarg(&args);
  435.     elseexpr = (args ? xlarg(&args) : NIL);
  436.     xllastarg(args);
  437.  
  438.     /* evaluate the appropriate clause */
  439.     return (xleval(xleval(testexpr) ? thenexpr : elseexpr));
  440. }
  441.  
  442. /* xlet - special form 'let' */
  443. NODE *xlet(args)
  444.   NODE *args;
  445. {
  446.     return (let(args,TRUE));
  447. }
  448.  
  449. /* xletstar - special form 'let*' */
  450. NODE *xletstar(args)
  451.   NODE *args;
  452. {
  453.     return (let(args,FALSE));
  454. }
  455.  
  456. /* let - common let routine */
  457. LOCAL NODE *let(args,pflag)
  458.   NODE *args; int pflag;
  459. {
  460.     NODE ***oldstk,*newenv,*val;
  461.  
  462.     /* create a new stack frame */
  463.     oldstk = xlstack;
  464.     xlsave1(newenv);
  465.  
  466.     /* create a new environment frame */
  467.     newenv = xlframe(xlenv);
  468.  
  469.     /* get the list of bindings and bind the symbols */
  470.     if (!pflag) xlenv = newenv;
  471.     dobindings(xlmatch(LIST,&args),newenv);
  472.     if (pflag) xlenv = newenv;
  473.  
  474.     /* execute the code */
  475.     for (val = NIL; consp(args); args = cdr(args))
  476.     val = xleval(car(args));
  477.  
  478.     /* unbind the arguments */
  479.     xlenv = cdr(xlenv);
  480.  
  481.     /* restore the previous stack frame */
  482.     xlstack = oldstk;
  483.  
  484.     /* return the result */
  485.     return (val);
  486. }
  487.  
  488. /* xprog - special form 'prog' */
  489. NODE *xprog(args)
  490.   NODE *args;
  491. {
  492.     return (prog(args,TRUE));
  493. }
  494.  
  495. /* xprogstar - special form 'prog*' */
  496. NODE *xprogstar(args)
  497.   NODE *args;
  498. {
  499.     return (prog(args,FALSE));
  500. }
  501.  
  502. /* prog - common prog routine */
  503. LOCAL NODE *prog(args,pflag)
  504.   NODE *args; int pflag;
  505. {
  506.     NODE ***oldstk,*newenv,*val;
  507.  
  508.     /* create a new stack frame */
  509.     oldstk = xlstack;
  510.     xlsave1(newenv);
  511.  
  512.     /* create a new environment frame */
  513.     newenv = xlframe(xlenv);
  514.  
  515.     /* get the list of bindings and bind the symbols */
  516.     if (!pflag) xlenv = newenv;
  517.     dobindings(xlmatch(LIST,&args),newenv);
  518.     if (pflag) xlenv = newenv;
  519.  
  520.     /* execute the code */
  521.     tagblock(args,&val);
  522.  
  523.     /* unbind the arguments */
  524.     xlenv = cdr(xlenv);
  525.  
  526.     /* restore the previous stack frame */
  527.     xlstack = oldstk;
  528.  
  529.     /* return the result */
  530.     return (val);
  531. }
  532.  
  533. /* xgo - special form 'go' */
  534. NODE *xgo(args)
  535.   NODE *args;
  536. {
  537.     NODE *label;
  538.  
  539.     /* get the target label */
  540.     label = xlarg(&args);
  541.     xllastarg(args);
  542.  
  543.     /* transfer to the label */
  544.     xlgo(label);
  545. }
  546.  
  547. /* xreturn - special form 'return' */
  548. NODE *xreturn(args)
  549.   NODE *args;
  550. {
  551.     NODE *val;
  552.  
  553.     /* get the return value */
  554.     val = (args ? xlevarg(&args) : NIL);
  555.     xllastarg(args);
  556.  
  557.     /* return from the inner most block */
  558.     xlreturn(val);
  559. }
  560.  
  561. /* xprog1 - special form 'prog1' */
  562. NODE *xprog1(args)
  563.   NODE *args;
  564. {
  565.     return (progx(args,1));
  566. }
  567.  
  568. /* xprog2 - special form 'prog2' */
  569. NODE *xprog2(args)
  570.   NODE *args;
  571. {
  572.     return (progx(args,2));
  573. }
  574.  
  575. /* progx - common progx code */
  576. LOCAL NODE *progx(args,n)
  577.   NODE *args; int n;
  578. {
  579.     NODE ***oldstk,*val;
  580.  
  581.     /* create a new stack frame */
  582.     oldstk = xlstack;
  583.     xlsave1(val);
  584.  
  585.     /* evaluate the first n expressions */
  586.     for (; consp(args) && --n >= 0; args = cdr(args))
  587.     val = xleval(car(args));
  588.  
  589.     /* evaluate each remaining argument */
  590.     for (; consp(args); args = cdr(args))
  591.     xleval(car(args));
  592.  
  593.     /* restore the previous stack frame */
  594.     xlstack = oldstk;
  595.  
  596.     /* return the last test expression value */
  597.     return (val);
  598. }
  599.  
  600. /* xprogn - special form 'progn' */
  601. NODE *xprogn(args)
  602.   NODE *args;
  603. {
  604.     NODE *val;
  605.  
  606.     /* evaluate each expression */
  607.     for (val = NIL; consp(args); args = cdr(args))
  608.     val = xleval(car(args));
  609.  
  610.     /* return the last test expression value */
  611.     return (val);
  612. }
  613.  
  614. /* xdo - special form 'do' */
  615. NODE *xdo(args)
  616.   NODE *args;
  617. {
  618.     return (doloop(args,TRUE));
  619. }
  620.  
  621. /* xdostar - special form 'do*' */
  622. NODE *xdostar(args)
  623.   NODE *args;
  624. {
  625.     return (doloop(args,FALSE));
  626. }
  627.  
  628. /* doloop - common do routine */
  629. LOCAL NODE *doloop(args,pflag)
  630.   NODE *args; int pflag;
  631. {
  632.     NODE ***oldstk,*newenv,*blist,*clist,*test,*rval;
  633.     int rbreak;
  634.  
  635.     /* create a new stack frame */
  636.     oldstk = xlstack;
  637.     xlsave1(newenv);
  638.  
  639.     /* get the list of bindings, the exit test and the result forms */
  640.     blist = xlmatch(LIST,&args);
  641.     clist = xlmatch(LIST,&args);
  642.     test = (consp(clist) ? car(clist) : NIL);
  643.  
  644.     /* create a new environment frame */
  645.     newenv = xlframe(xlenv);
  646.  
  647.     /* bind the symbols */
  648.     if (!pflag) xlenv = newenv;
  649.     dobindings(blist,newenv);
  650.     if (pflag) xlenv = newenv;
  651.  
  652.     /* execute the loop as long as the test is false */
  653.     for (rbreak = FALSE; xleval(test) == NIL; doupdates(blist,pflag))
  654.     if (tagblock(args,&rval)) {
  655.         rbreak = TRUE;
  656.         break;
  657.     }
  658.  
  659.     /* evaluate the result expression */
  660.     if (!rbreak && consp(clist))
  661.     for (rval = NIL, clist = cdr(clist); consp(clist); clist = cdr(clist))
  662.         rval = xleval(car(clist));
  663.  
  664.     /* unbind the arguments */
  665.     xlenv = cdr(xlenv);
  666.  
  667.     /* restore the previous stack frame */
  668.     xlstack = oldstk;
  669.  
  670.     /* return the result */
  671.     return (rval);
  672. }
  673.  
  674. /* xdolist - special form 'dolist' */
  675. NODE *xdolist(args)
  676.   NODE *args;
  677. {
  678.     NODE ***oldstk,*clist,*sym,*list,*rval;
  679.     int rbreak;
  680.  
  681.     /* create a new stack frame */
  682.     oldstk = xlstack;
  683.     xlsave1(list);
  684.  
  685.     /* get the control list (sym list result-expr) */
  686.     clist = xlmatch(LIST,&args);
  687.     sym = xlmatch(SYM,&clist);
  688.     list = xlevmatch(LIST,&clist);
  689.  
  690.     /* initialize the local environment */
  691.     xlenv = xlframe(xlenv);
  692.     xlbind(sym,NIL,xlenv);
  693.  
  694.     /* loop through the list */
  695.     for (rbreak = FALSE; consp(list); list = cdr(list)) {
  696.  
  697.     /* bind the symbol to the next list element */
  698.     xlsetvalue(sym,car(list));
  699.  
  700.     /* execute the loop body */
  701.     if (tagblock(args,&rval)) {
  702.         rbreak = TRUE;
  703.         break;
  704.     }
  705.     }
  706.  
  707.     /* evaluate the result expression */
  708.     if (!rbreak) {
  709.     xlsetvalue(sym,NIL);
  710.     rval = (consp(clist) ? xleval(car(clist)) : NIL);
  711.     }
  712.  
  713.     /* unbind the arguments */
  714.     xlenv = cdr(xlenv);
  715.  
  716.     /* restore the previous stack frame */
  717.     xlstack = oldstk;
  718.  
  719.     /* return the result */
  720.     return (rval);
  721. }
  722.  
  723. /* xdotimes - special form 'dotimes' */
  724. NODE *xdotimes(args)
  725.   NODE *args;
  726. {
  727.     NODE *clist,*sym,*rval;
  728.     int rbreak,cnt,i;
  729.  
  730.     /* get the control list (sym list result-expr) */
  731.     clist = xlmatch(LIST,&args);
  732.     sym = xlmatch(SYM,&clist);
  733.     cnt = getfixnum(xlevmatch(INT,&clist));
  734.  
  735.     /* initialize the local environment */
  736.     xlenv = xlframe(xlenv);
  737.     xlbind(sym,NIL,xlenv);
  738.  
  739.     /* loop through for each value from zero to cnt-1 */
  740.     for (rbreak = FALSE, i = 0; i < cnt; ++i) {
  741.  
  742.     /* bind the symbol to the next list element */
  743.     xlsetvalue(sym,cvfixnum((FIXNUM)i));
  744.  
  745.     /* execute the loop body */
  746.     if (tagblock(args,&rval)) {
  747.         rbreak = TRUE;
  748.         break;
  749.     }
  750.     }
  751.  
  752.     /* evaluate the result expression */
  753.     if (!rbreak) {
  754.     xlsetvalue(sym,cvfixnum((FIXNUM)cnt));
  755.     rval = (consp(clist) ? xleval(car(clist)) : NIL);
  756.     }
  757.  
  758.     /* unbind the arguments */
  759.     xlenv = cdr(xlenv);
  760.  
  761.     /* return the result */
  762.     return (rval);
  763. }
  764.  
  765. /* xcatch - special form 'catch' */
  766. NODE *xcatch(args)
  767.   NODE *args;
  768. {
  769.     NODE ***oldstk,*tag,*val;
  770.     CONTEXT cntxt;
  771.  
  772.     /* create a new stack frame */
  773.     oldstk = xlstack;
  774.     xlsave1(tag);
  775.  
  776.     /* get the tag */
  777.     tag = xlevarg(&args);
  778.  
  779.     /* establish an execution context */
  780.     xlbegin(&cntxt,CF_THROW,tag);
  781.  
  782.     /* check for 'throw' */
  783.     if (setjmp(cntxt.c_jmpbuf))
  784.     val = xlvalue;
  785.  
  786.     /* otherwise, evaluate the remainder of the arguments */
  787.     else {
  788.     for (val = NIL; consp(args); args = cdr(args))
  789.         val = xleval(car(args));
  790.     }
  791.     xlend(&cntxt);
  792.  
  793.     /* restore the previous stack frame */
  794.     xlstack = oldstk;
  795.  
  796.     /* return the result */
  797.     return (val);
  798. }
  799.  
  800. /* xthrow - special form 'throw' */
  801. NODE *xthrow(args)
  802.   NODE *args;
  803. {
  804.     NODE *tag,*val;
  805.  
  806.     /* get the tag and value */
  807.     tag = xlevarg(&args);
  808.     val = (args ? xlevarg(&args) : NIL);
  809.     xllastarg(args);
  810.  
  811.     /* throw the tag */
  812.     xlthrow(tag,val);
  813. }
  814.  
  815. /* xerrset - special form 'errset' */
  816. NODE *xerrset(args)
  817.   NODE *args;
  818. {
  819.     NODE *expr,*flag,*val;
  820.     CONTEXT cntxt;
  821.  
  822.     /* get the expression and the print flag */
  823.     expr = xlarg(&args);
  824.     flag = (args ? xlarg(&args) : true);
  825.     xllastarg(args);
  826.  
  827.     /* establish an execution context */
  828.     xlbegin(&cntxt,CF_ERROR,flag);
  829.  
  830.     /* check for error */
  831.     if (setjmp(cntxt.c_jmpbuf))
  832.     val = NIL;
  833.  
  834.     /* otherwise, evaluate the expression */
  835.     else {
  836.     expr = xleval(expr);
  837.     val = consa(expr);
  838.     }
  839.     xlend(&cntxt);
  840.  
  841.     /* return the result */
  842.     return (val);
  843. }
  844.  
  845. /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
  846. LOCAL dobindings(list,env)
  847.   NODE *list,*env;
  848. {
  849.     NODE ***oldstk,*bnd,*sym,*val;
  850.  
  851.     /* create a new stack frame */
  852.     oldstk = xlstack;
  853.     xlsave1(val);
  854.  
  855.     /* bind each symbol in the list of bindings */
  856.     for (; consp(list); list = cdr(list)) {
  857.  
  858.     /* get the next binding */
  859.     bnd = car(list);
  860.  
  861.     /* handle a symbol */
  862.     if (symbolp(bnd)) {
  863.         sym = bnd;
  864.         val = NIL;
  865.     }
  866.  
  867.     /* handle a list of the form (symbol expr) */
  868.     else if (consp(bnd)) {
  869.         sym = xlmatch(SYM,&bnd);
  870.         val = xlevarg(&bnd);
  871.     }
  872.     else
  873.         xlfail("bad binding");
  874.  
  875.     /* bind the value to the symbol */
  876.     xlbind(sym,val,env);
  877.     }
  878.  
  879.     /* restore the previous stack frame */
  880.     xlstack = oldstk;
  881. }
  882.  
  883. /* doupdates - handle updates for do/do* */
  884. doupdates(list,pflag)
  885.   NODE *list; int pflag;
  886. {
  887.     NODE ***oldstk,*plist,*bnd,*sym,*val;
  888.  
  889.     /* create a new stack frame */
  890.     oldstk = xlstack;
  891.     xlstkcheck(2);
  892.     xlsave(plist);
  893.     xlsave(val);
  894.  
  895.     /* bind each symbol in the list of bindings */
  896.     for (; consp(list); list = cdr(list)) {
  897.  
  898.     /* get the next binding */
  899.     bnd = car(list);
  900.  
  901.     /* handle a list of the form (symbol expr) */
  902.     if (consp(bnd)) {
  903.         sym = xlmatch(SYM,&bnd);
  904.         bnd = cdr(bnd);
  905.         if (bnd) {
  906.         val = xlevarg(&bnd);
  907.         if (pflag)
  908.             plist = cons(cons(sym,val),plist);
  909.         else
  910.             xlsetvalue(sym,val);
  911.         }
  912.     }
  913.     }
  914.  
  915.     /* set the values for parallel updates */
  916.     for (; plist; plist = cdr(plist))
  917.     xlsetvalue(car(car(plist)),cdr(car(plist)));
  918.  
  919.     /* restore the previous stack frame */
  920.     xlstack = oldstk;
  921. }
  922.  
  923. /* tagblock - execute code within a block and tagbody */
  924. int tagblock(code,pval)
  925.   NODE *code,**pval;
  926. {
  927.     CONTEXT cntxt;
  928.     int type,sts;
  929.  
  930.     /* establish an execution context */
  931.     xlbegin(&cntxt,CF_GO|CF_RETURN,code);
  932.  
  933.     /* check for a 'return' */
  934.     if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
  935.     *pval = xlvalue;
  936.     sts = TRUE;
  937.     }
  938.  
  939.     /* otherwise, enter the body */
  940.     else {
  941.  
  942.     /* check for a 'go' */
  943.     if (type == CF_GO)
  944.         code = xlvalue;
  945.  
  946.     /* evaluate each expression in the body */
  947.     for (; consp(code); code = cdr(code))
  948.         if (consp(car(code)))
  949.         xleval(car(code));
  950.  
  951.     /* fell out the bottom of the loop */
  952.     *pval = NIL;
  953.     sts = FALSE;
  954.     }
  955.     xlend(&cntxt);
  956.  
  957.     /* return status */
  958.     return (sts);
  959. }
  960.  
  961.